perm filename TRANSF.F4[IRC,LCS] blob
sn#646476 filedate 1982-03-07 generic text, type T, neo UTF8
C READS IN TWO FILES FOR TRANSFORMATION
IMPLICIT INTEGER (X-Z)
DIMENSION RN(3)
C RN WILL HOLD FILE NAMES
COMMON /A/X1(800),Y1(800),Z1(800),K1
COMMON /B/X2(800),Y2(800),Z2(800),K2
COMMON /C/X3(800),Y3(800),Z3(800),K3
COMMON /D/X4(800),Y4(800),Z4(800),K4
CALL READX(1)
CALL READX(2)
C IF(K1.LT.K2)GO TO 1
C CALL REVERS
C1 CALL EQUALO
C ASSUMES OUTLINE IS FIRST LONG CONTINUOUS LINE.
C FIRST EQUALIZES OUTLINE, THEN THE REST
C CALL EQUALZ
CALL EQUAL
2 CALL PRCNTQ
CALL OUTPUT
100 END
SUBROUTINE EQUAL
COMMON /A/X1(800),Y1(800),Z1(800),K1
COMMON /D/X4(800),Y4(800),Z4(800),K4
COMMON /B/X2(800),Y2(800),Z2(800),K2
COMMON /C/X3(800),Y3(800),Z3(800),K3
L=1
K=1
M=0
4 I=K
J=L
CALL SEG(Z1,K,K1,NN1)
CALL SEG(Z2,L,K2,NN2)
A=NN1
B=NN2
IF(NN1.GT.NN2)GO TO 1
C=A/B
D=I
2 DO 3 KK=J,L
M=M+1
N=D
X4(M)=X2(KK)
Y4(M)=Y2(KK)
C Z4(M)=Z2(KK)
X3(M)=X1(N)
Y3(M)=Y1(N)
Z3(M)=Z2(KK)
3 D=D+C
6 K=K+1
L=L+1
IF(K.LT.K1)GO TO 4
K3=M
RETURN
1 C=B/A
D=J
DO 5 KK=I,K
M=M+1
N=D
X3(M)=X1(KK)
Y3(M)=Y1(KK)
Z3(M)=Z1(KK)
X4(M)=X2(N)
Y4(M)=Y2(N)
C Z4(M)=Z2(KK)
5 D=D+C
GO TO 6
END
SUBROUTINE SEG(Z,K,K1,NN)
DIMENSION Z(1)
DO 1 N=K+1,K1
1 IF(Z(N).NE.0)GO TO 2
N=K1+1
2 NN=N-K
K=N-1
END
SUBROUTINE PRCNTQ
IMPLICIT INTEGER (X-Z)
COMMON /A/X1(800),Y1(800),Z1(800),K1
COMMON /B/X2(800),Y2(800),Z2(800),K2
COMMON /C/X3(800),Y3(800),Z3(800),K3
COMMON /D/X4(800),Y4(800),Z4(800),K4
10 FORMAT(' TYPE PERCENT OF TRANSFORMATION (.5=50%) '$)
11 FORMAT(F)
TYPE 10
ACCEPT 11,P
DO 1 K=1,K3
A=X4(K)-X3(K)
A=A*P+.5
B=Y4(K)-Y3(K)
B=B*P+.5
X3(K)=X3(K)+A
1 Y3(K)=Y3(K)+B
END
SUBROUTINE READX(N)
C READS IN TWO FILES FOR TRANSFORMATION
IMPLICIT INTEGER (X-Z)
DIMENSION RN(3)
C RN WILL HOLD FILE NAMES
COMMON /A/X1(800),Y1(800),Z1(800),K1
COMMON /B/X2(800),Y2(800),Z2(800),K2
COMMON /C/X3(800),Y3(800),Z3(800),K3
1 FORMAT(' TYPE FILE NAME '$)
2 FORMAT(A5)
3 FORMAT(4I)
WRITE(5,1)
READ(5,2)RN(N)
NUM=1
REWIND NUM
CALL IFILE(NUM,RN(N))
GO TO (10,20),N
C K1 AND K2 WILL HOLD TOTAL OF POINTS.
10 K1=1
100 READ(NUM,3,END=12)K,X1(K1),Y1(K1),Z1(K1)
K1=K1+1
GO TO 100
12 K1=K1-1
RETURN
20 K2=1
200 READ(NUM,3,END=11)K,X2(K2),Y2(K2),Z2(K2)
K2=K2+1
GO TO 200
11 K2=K2-1
END
SUBROUTINE REVERS
C REVERSES A AND B DATA. B MUST BE GREATER
COMMON /A/X1(800),Y1(800),Z1(800),K1
COMMON /B/X2(800),Y2(800),Z2(800),K2
COMMON /C/X3(800),Y3(800),Z3(800),K3
DO 1 K=1,K1
X3(K)=X1(K)
Y3(K)=Y1(K)
1 Z3(K)=Z1(K)
K3=K1
DO 27 K=1,K2
X1(K)=X2(K)
Y1(K)=Y2(K)
27 Z1(K)=Z2(K)
K1=K2
DO 3 K=1,K3
X2(K)=X3(K)
Y2(K)=Y3(K)
3 Z2(K)=Z3(K)
K2=K3
END
SUBROUTINE FINDO(J,JOUT)
DIMENSION J(1)
DO 1 K=2,JOUT
1 IF(J(K).NE.0)GO TO 2
2 JOUT=K-1
C TOTAL POINTS IN OUTLINE
END
SUBROUTINE OUTPUT
IMPLICIT INTEGER (X-Z)
COMMON /A/X1(800),Y1(800),Z1(800),K1
COMMON /B/X2(800),Y2(800),Z2(800),K2
COMMON /C/X3(800),Y3(800),Z3(800),K3
1 FORMAT(' TYPE OUTPUT FILE NAME '$)
2 FORMAT(A5)
TYPE 1
ACCEPT 2,NAM
IF(NAM.NE.'DPY')GO TO 20
3 FORMAT(3I4,I2,3X,3I4,I2,3X,3I4,I2,3X,3I4,I2)
J=K3/4+1
DO 4 K=1,J
L=K+J
M=K+J+J
N=K+J+J+J
TYPE 3,K,X3(K),Y3(K),Z3(K),L,X3(L),Y3(L),Z3(L),
3 M,X3(M),Y3(M),Z3(M),N,X3(N),Y3(N),Z3(N)
4 CONTINUE
PAUSE
20 CALL OFILE(1,NAM)
K1=0
DO 21 K=1,K3
IF(Z3(K).NE.0)GO TO 28
C LOOK FOR REDUNDANT POINTS
J=X3(K)
IF(J.EQ.X3(K+1).AND.J.EQ.X3(K+2))GO TO 21
J=Y3(K)
IF(J.EQ.Y3(K+1).AND.J.EQ.Y3(K+2))GO TO 21
28 K1=K1+1
X1(K1)=X3(K)
Y1(K1)=Y3(K)
Z1(K1)=Z3(K)
21 CONTINUE
22 FORMAT(3I4,I2)
DO 25 K=1,340
IF(K.LT.320)GO TO 25
IF(Z1(K).NE.0)GO TO 200
25 WRITE(1,22)K,X1(K),Y1(K),Z1(K)
200 END FILE 1
NAM=NAM+2
C BE SURE TO USE 5-LETTER NAME ONLY.
CALL OFILE(1,NAM)
M=0
N=K
DO 23 K=N,K1
M=M+1
23 WRITE(1,22)M,X1(K),Y1(K),Z1(K)
END FILE 1
END